perm filename FS[IL,LSP] blob
sn#082813 filedate 1974-01-19 generic text, type T, neo UTF8
00100 SUBTTL LISP ATOMS AND OBLIST
00200 FS:
00300
00310 DEFINE GS<GENCNT+<GENCNT←←GENCNT+1>>
00320 GENCNT←←0 ;COUNTER FOR FAKE GENERATED SYMBOLS.
00330
00400 DEFINE MAKBUC ' (A,QQ)
00500 <DEFINE OBT'A <G'QQ←.>
00600 XWD G'QQ,IFN <<BCKETS-1>-A>,<.+1>
00700 >
00800
00900 DEFINE ADDOB ' (A,C,QQ)
01000 <OBT'A
01100 DEFINE OBT'A<G'QQ←.>
01300 XWD C,G'QQ>
01400
01500 DEFINE PUTOB ' (A,B)
01600 <ZZ←←<ASCII +A+>←<-1>
01700 ZZ←←-ZZ/BCKETS*BCKETS+ZZ
01800 ADDOB \ZZ,B,→GS>
01900
02000 DEFINE PSTRCT ' (A)
02100 <ZZ←←[ASCII +A+]
02200 LENGTH(ZY,<A>)
02300 ZY←←<ZY-1>/5
02400 Q1(ZY,ZZ)
02500 >
02600
02700 DEFINE Q1 ' (N,Z)<
02800 IFN N,<XWD Z,[Q1(N-1,Z+1)]>
02900 IFE N,<XWD Z,0>>
03000
03100
03200 ;## ARGS ARE A←NAME, B←PROP NAME, C'A←THE PROPERTY, D←LABEL OF ATOM
03300
03400 DEFINE MKAT ' (A,B,C,D)
03500 <XLIST
03600 FOR XXX ⊂ A< PUTOB XXX,.+1
03700 D XWD -1,.+1
03800 XWD B,.+1
03900 XWD C'XXX,.+1
04000 XWD PNAME,.+1
04100 XWD [PSTRCT(XXX)],0>
04200 LIST>
04300
04400 ;## ARGS ARE: D'A←PROPERTY, B←PROP NAME, C←NAME
04500
04600 DEFINE MKAT1 ' (A,B,C,D)
04700 <XLIST
04800 FOR XXX⊂ C <PUTOB XXX,.+1
04900 XWD -1,.+1
05000 XWD B,.+1
05100 XWD D'A,.+1
05200 XWD PNAME,.+1
05300 XWD [PSTRCT(XXX)],0>
05400 LIST>
05500
05600 DEFINE LENGTH ' (A,B)
05700 <A←←0
05800 FOR XεB<A←←A+1>>
05900
06000 ;## ATOM WITH SYM PROPERTY ←V'ATOM LOCATION
06100 DEFINE ML1 ' (A)<FOR XXX⊂A<
06200 V'XXX: XWD -1,.+1
06300 XWD FIXNUM,[XXX]
06400 MKAT XXX,SYM,V
06500 >>
06600
06700 ;## SIMILAR TO ML1, EXCEPT G'QQ←THE SYM PROP
06800
06900 DEFINE MKSY1 ' (A,B,QQ)<
07000 XLIST
07100 G'QQ: XWD -1,.+1
07200 XWD FIXNUM,[A]
07300 PUTOB B,.+1
07400 XWD -1,.+1
07500 XWD SYM,.+1
07600 XWD G'QQ,.+1
07700 XWD PNAME,.+1
07800 XWD [PSTRCT(B)],0
07900 LIST>
08000
08100 ;## ATOM WITH NO PROPS WITH LABEL SAME AS ATOM NAME
08200
08300 DEFINE ML ' (A)<
08400 XLIST
08500 FOR XXX⊂A,<PUTOB XXX,.+1
08600 XXX: XWD -1,.+1
08700 XWD PNAME,.+1
08800 XWD [PSTRCT(XXX)],0>
08900 LIST>
09000 ;## CREATE ATOM WITH NO LABEL OR PROPS. USED FOR COMMON ATMS IN SYSTEM
09100
09200 DEFINE MK ' (A)<
09300 XLIST
09400 FOR XXX⊂A,<PUTOB XXX,.+1
09500 XWD -1,.+1
09600 XWD PNAME,.+1
09700 XWD [PSTRCT(XXX)],0>
09800 LIST>
09900
10000 OBTBL:
10100 OBLIST: ZZ←←0
10200 XLIST
10300 REPEAT BCKETS,<MAKBUC \ZZ,→GS
10400 ZZ←←ZZ+1>
10500 LIST
10600
00100 ;THE GREAT OBLIST EXPLOSION...
00200
00300 ;## GENERATE # FNS ONLY IF NONUSEFUL VALUES DESIRED
00400 IFN NONUSE<
00500 MKAT1 MEMBR.,SUBR,MEMBER#
00600 MKAT1 MEMB,SUBR,MEMQ#
00700 MKAT1 AND.,FSUBR,AND#
00800 MKAT1 OR.,FSUBR,OR#
00900 >
01000 MKAT<RPLACA,RPLACD,MINUS,TERPRI,CAR,CDR,CAAR,USETI,USETO>,SUBR
01100 MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
01200 MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
01300 MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
01400 MKAT<STRINGP,ATOM,PATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
01500 MKAT<GCGAG,CHRCT,LINELENGTH,NUMBERP,EQUAL,GET,INTERN,MEMBER>,SUBR
01600 MKAT<LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
01700 MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
01800 MKAT<GCTIME,REVERSE,SPEAK,GC,GETL,BAKGAG,MEMQ>,SUBR
01900 MKAT<PUTPROP,PRINC,FLATSIZE,ERR,EXAMINE,DEPOSIT,LSH>,SUBR
02000 MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP>,SUBR
02100 MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMSYM,REMAINDER,ABS>,SUBR
02200 MKAT<PROG1,SPRINT,LITATOM,NTHCHAR>,SUBR
02300 IFN STPGAP,<MAKAT<PGLINE>,SUBR>
02400
02500 MKAT EXPLODEC,SUBR,%
02600 MKAT TAB,SUBR,.
02700 MKAT TYO,SUBR,I
02800 MKAT TYI,SUBR,I
02900 CEVAL=.+1
03000 MKAT1 EVAL,SUBR,*EVAL
03100
03200 ;$$ REDEF. FOR NEW MAP FUNCTIONS
03300 MKAT<MAPCAN,MAPCON,MAPLIST,MAPCAR,MAP,MAPC>,LSUBR
03400 ;$$ GIVE MAPCAN THE DOUBLE NAME MAPCONC
03500 MKAT1 MAPCAN,LSUBR,MAPCONC
03600
03700 PROGAT: MKAT<PROG>,FSUBR
03800
03900 ;##LIST STARTS HERE
04000 MKAT LIST,FSUBR,,LISTAT:
04100
04200 MKAT <PROGN,COND,SETQ,INPUT,OUTPUT,SETSYS>,FSUBR
04300 IFN ALVINE,<MKAT<GRINDEF>,FSUBR
04400 MKAT<ED>,SUBR>
04500 IFE ALVINE,<MK<GRINDEF>>
04600 MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
04700 MKAT<AND,DEFPROP,CSYM,EXARRAY,INOUT>,FSUBR
04800 MKAT1 QUOTE,FSUBR,FUNCTION
04900 MKAT1 %CLRBFI,SUBR,CLRBFI
05000 MKAT1 .ERROR,SUBR,ERROR
05100 MKAT1 LINRD,SUBR,LINEREAD
05200 MKAT1 UNBOND,SUBR,UNBOUND
05300 MKAT1 ECHO,SUBR,TTYECHO
05400 MKAT1 FUNCT,FSUBR,*FUNCTION
05500 MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR
05600
05700 ;## LABELS ON READ AND LISP EVAL FOR BOOTS
05800 MKAT READ,SUBR,,READAT:
05900 MKAT EVAL,LSUBR,O,EVALAT:
06000 MKAT ASCII,SUBR,A
06100 MKAT QUOTE,FSUBR,,CQUOTE:
06200 MKAT INUM0,SYM
06300
06400 PUTOB T,.+1
06500 TRUTH: XWD -1,.+1
06600 XWD VALUE,.+1
06700 XWD VTRUTH,.+1
06800 XWD PNAME,.+1
06900 XWD [PSTRCT(T)],0
07000 VTRUTH: TRUTH
07100
07200 PUTOB NIL,0
07300 CNIL2: XWD VALUE,.+1
07400 XWD VNIL,.+1
07500 XWD PNAME,.+1
07600 XWD [PSTRCT(NIL)],0
07700 VNIL: NIL
07800
07900 PUTOB *SAVIOB,.+1
08000 XWD -1,.+1
08100 XWD VALUE,.+1
08200 XWD SAVIOB,.+1
08300 XWD PNAME,.+1
08400 XWD .+1,0
08500 PSTRCT *SAVIOB
08600 SAVIOB: NIL
08700
08800 MKSY1 %LCALL,*LCALL,→GS
08900 MKSY1 %AMAKE,*AMAKE,→GS
09000 MKSY1 %UDT,*UDT,→GS
09100 MKSY1 .MAPC,*MAPC,→GS
09200 MKSY1 .MAP,*MAP,→GS
09300 MKAT1 %NOPOINT,VALUE,*NOPOINT
09400 %NOPOINT: NIL
09500
09600
09700 UNBOUND: XWD -1,.+1
09800 XWD PNAME,.+1
09900 XWD [PSTRCT(UNBOUND)],0
10000 PAGE
10100 MKAT1 EXPN1,SUBR,*EXPAND1
10200 MKAT1 EXPAND,SUBR,*EXPAND
10300 MKAT1 PLUS,SUBR,*PLUS,.
10400 MKAT1 DIF,SUBR,*DIF,.
10500 MKAT1 QUO,SUBR,*QUO,.
10600 MKAT1 TIMES,SUBR,*TIMES,.
10700 MKAT1 APPEND,SUBR,*APPEND,.
10800 MKAT1 RSET,SUBR,*RSET,.
10900 MKAT1 GREAT,SUBR,*GREAT,.
11000 MKAT1 LESS,SUBR,*LESS,.
11100 MKAT1 PUTSYM,SUBR,*PUTSYM
11200 MKAT1 GETSYM,SUBR,*GETSYM
11300 MKAT1 RPTSYM,SUBR,*RPUTSYM
11400 MKAT1 RGTSYM,SUBR,*RGETSYM
11500
11600 ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>
11700
11800 PUTOB NUMVAL,.+1
11900 XWD -1,.+1
12000 XWD SUBR,.+1
12100 XWD NUMVAL,.+1
12200 XWD SYM,.+3
12300 XWD FIXNUM,[NUMVAL]
12400 XWD -1,.-1
12500 XWD .-1,.+1
12600 XWD PNAME,.+1
12700 XWD [PSTRCT(NUMVAL)],0
12800
12900 MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V
13000
13100
13200 ;## QUEUE ATOMS AND OTHER NEW FNS.
13300
13400 MKAT<GTBLK,ERRCH,RDNAM>,SUBR
13500 MKAT<INUMP,NUMTYPE>,SUBR
13600 MKAT<UFDINP,RDFILE,MYPPN,BLKLST>,SUBR
13700 MKAT<RENAME,DELETE,INITFL>,FSUBR
13800 IFN QALLOW<MKAT <QUEUE>,FSUBR>
13900 ML<CPU,FORMS,LIMIT,COPIES,DISP>
14000 MK<SUBST,COPY,*RENAME,FILBAK,LBK,DIR>
14100 MKAT1 ISFILE,SUBR,LOOKUP
14200 MK<NO BACKUP >
14300
14400 ;## MOST OF THE EXTENDED SWITCHES (NOT ALL)
14500 IFN QSWEXT<
14600 ML<DEAD,AFTER>
14700 ML<MODIFY,KILL,JOB,DEPND,UNIQUE>
14800 ML<PAGES,PLOT,PTAPE,CARD,SEQ,PRIOR,SPACE,LIMIT,HEAD>
14900 > ;##END OF EXTENDED SWITCHES
15000
15100 ;$$ATOMS FOR DEFINITIONS OF FUNCTIONS FOR NEW SPDL PACKAGE
15200
15300 ML ERRORX
15400 MKAT1 INTPRP,SUBR,INITPROMPT
15500 MKAT1 LSPRET,FSUBR,**TOP**
15600 MKAT<PROMPT,READP,UNTYI,STKPTR,SPREDO,SPREVAL>,SUBR
15700 MKAT<MEMB,NEXTEV>,SUBR
15800 MKAT<SPDLFT,SPDLRT,SPDLPT>,SUBR
15900 MKAT<EVALV,OUTVAL>,SUBR
16000
16100 ;$$ MORE EXTENSIONS INCLUDING READ MACROS
16200 ML READMACRO
16300 MKAT1 %FLATSIZEC,SUBR,FLATSIZEC
16400 MKAT <NEQ,CONSP,CHRVAL,SETCHR,MODCHR,LEXORDER>,SUBR
16500 MKAT <FREE,FREELIST,SYSCLR,HGHCOR,HGHORG,HGHEND>,SUBR
16600 MKAT1 FALSE,FSUBR,SPECIAL
16700 MKAT1 FALSE,FSUBR,NOCALL
16800 MKAT1 FALSE,FSUBR,DECLARE
16900 MKAT1 FALSE,FSUBR,NILL
17000 MKAT1 APPLY.,SUBR,APPLY#
17100 MKAT1 .MAX,SUBR,*MAX
17200 MKAT1 .MIN,SUBR,*MIN
17300
17400 ;$$ THE BREAK VARIABLES WHICH TELL ABOUT DEPTH IN THE BREAK PACKAGE
17500 MKAT1 BIOCHN,VALUE,#%IOCHANS%#
17600 MKAT1 BPMPT,VALUE,#%PROMPTS%#
17700 MKAT1 BINDNT,VALUE,#%INDENT
17800 BIOCHN: NIL
17900 BPMPT: NIL
18000 BINDNT: INUM0
18100
18200 VOBLIST: OBLIST
18300 VBASE: 8+INUM0
18400 VIBASE: 8+INUM0
18500
18600 ML <PNAME,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,SYM,∨
18700 $EOF$,LABEL,FUNARG,LSUBR,MACRO>
18800
18900 PUTOB ?,.+1
19000 QST: XWD -1,.+1
19100 XWD PNAME,.+1
19200 XWD [PSTRCT(?)],0
19300
19400 VBPORG: INUM0
19500 VBPEND: INUM0
19600
19700 ;MKAT ACHLOC,SYM
19800 ;DONT KNOW WHATS UP HERE, IF NEEDED CHECK ACHLOC
19900
20000 PAGE
20100 ;
00100 ; ALL THE ATOMS IN THE WHOLE SYSTEM
00200 MK<USERERRORX,RPUTSYM,RGETSYM>
00300 MK<A,ADD,AFTER,ALIAS,ARGPRINT,ASSOC#,ATM,B,BEFORE,BELOW,BEND1,BF,BI,BIND>
00400 MK<BK,BKE,BKEV,BKEVAL,BKF,BKFNLIST,BKFV,BKPOS,BKPROG,BKSETQ,BKV>
00500 MK<BLOCK,BLOCKED,BO,BORG1,BREAK>
00600 MK<BREAKMACROS,BREAK0,BREAK1,BREAK1ERX,BRKAPPLY>
00700 MK<BRKCOMS,BRKEXP,BRKFN,BRKTYPE,BRKWHEN,BROKEN,BROKENFNS>
00800 MK<BY,C,CAIE,CAIN,CALL,CALLF,CALLF@,CAME,CAMN,CAN'T,CHANGE>
00900 MK<CHNGDFLG,CLEARB,CLEARM,COM,COM0>
01000 MK<COMS,COMSQ,COPYFLG,CPTR,D,DE,DEFSYM,DELETE,DF>
01100 MK<DIFFERENCE,DIFFERENT EXPRESSION,DM,DREVERSE,DRM,DSKIN>
01200 MK<DSKOUT,DSM,DSUBST,E,EDIT,EDIT-SAVE>
01300 MK<EDIT4E,EDIT4F,EDIT4F1,EDIT:,EDITBF,EDIT1,EDITCOMSL>
01400 MK<EDITE,EDITF,EDITFNS,EDITFPAT>
01500 MK<EDITL,EDITL0,EDITL1,EDITMACROS,EDITMBD,EDITMV>
01600 MK<EDITOPS,EDITQF,EDITRACEFN,EDITXTR,EMBED,ENTER ,ERXACTION>
01700 MK<EX,EXCH,EXTRACT,F,F=,FF,FILES-LOADED,FINDFLAG,FNDBRKPT,FOR,FOUND>
01800 MK<FROM,FROM?=,FS,FUNTYPE,G,GETSYM,GREATERP,GRINL,GVAL>
01900 MK<GWD,HERE,HLLZS@,HLRZ,HLRZ@,HRLM@,HRRM,HRRM@,HRRZ,HRRZ@,HRRZS@>
02000 MK<I,IF,IN,INSERT,INSIDE,JCALL,JCALLF,JCALLF@,JRST,JSP>
02100 MK<JUMPE,JUMPN,KLIST,L,L0,L11,L12,LAP,LAPEVAL,LAPLST,LASTAIL>
02200 MK<LASTPOS,LASTWORD,LASTP1,LASTP2,LASTVALUE,LC,LCFLG,LCL,LDIFF,LESSP>
02300 MK<LEXPR,LI,LO,LP,LPQ,LPTLENGTH,LSUBST>
02400 MK<M,MARK,MARKLST,MAX,MAXLEVEL,MAXLEVEL EXCEEDED>
02500 MK<MAXLOOP,MAXLOOP EXCEEDED,MBD,MIN,MOVE,MOVEI,MOVEM>
02600 MK<MOVNI,MV,N,N?,NAMESCHANGED,NEX,NOT BLOCKED,NOT EDITABLE>
02700 MK<NOTHING SAVED,NTH,NX,OCCURRENCES,OK,OLDPROMPT,OPS,ORF,ORR>
02800 MK<P,PLEV,PLUS,POP,POPJ,PP,PREVEV,PRINLEV,PRINTLEV>
02900 MK<PUSH,PUSHJ,PUTSYM,QLIST,QUOTIENT,R,READBUF>
03000 MK<REDEFINED,REMOVE,REPACK,REPLACE,RETFROM,RI,RO> ;##REMOVE MARKER
03100 MK<S,SAVE,SECOND,SELECTQ,SN,SOJE,SOJN>
03200 MK<START,STKCOUNT,STKNAME,STKNTH>
03300 MK<STKSRCH,STOP,SUB,SUBPAIR,SURROUND,SW>
03400 MK<TAILP,TCONC,TDZA,TEST,THIRD,THROUGH,THRU,TIMES,TO>
03500 MK<TOFLG,TOPFLG,TRACE,TRACEDFNS,TTY:,TYPE,UNBLOCK,UNBREAK>
03600 MK<UNBREAK0,UNBREAKABLEFNS,UNDEF,UNDO>
03700 MK<UNDOLST,UNDOLST1,UNDONE,UNFIND,UNTRACE,UP>
03800 MK<UPFINDFLG,USE,USERMACROS,WHEN,WITH,X,XTR,Y,ZZ>
03900 MK<@,<\>,<\#\ >,<\P>,↑,↑↑,←,←←, , , ?, . ,< . UNBOUND)>>
04000 MK<- LOCATION UNCERTAIN, = ,! ,!0,!NX,!UNDO,!VALUE,##>
04100 MK<#1,#2,#3,$%DOTFLG,%%BKPOS,%%CMDL,%%V>
04200 MK<%DEFINE,%DEREAD,%DEVP,%ERDEPTH,%LOOKDPTH,%PREVFN%>
04300 MK<%PRINFN,%READIN,&,& ,<(>,<(DEFPROP >,<)>,*,*ANY*,*RSETERX,-->
04400 MK<-IN-,::,:::,/BREAK1,:,=,==,?=,??>
04500 MK<... , ...],BINARY PROGRAM SPACE EXCEEDED>
04600 MK<NOT A TAIL - LDIFF,NO EVAL BLIP - RETFROM>
04700 MK<BAD ARGUMENT - LCONC,BAD ARGUMENT - TCONC>
04800 MK<DSK:,INIT,LSP,NOT IN SYMBOL TABLE,& UNHAPPY>
04900 MK<ARGUMENTS NOT FOUND,NOT BREAKABLE FUNCTION,ARGUMENT LIST?>
05000 MK<AROUND,BREAKIN,EDBRK,BROKEN-IN,EDVAL,DREMOVE,LCONC,SUBLIS>
05100 MK<EDITDSUBST,MAKEFN,FNDEF,LXPD,WHERE,MESS>
05200 MK<SHOULD BE LIST,SHOULD BE LIST OF ATOMIC ARGUMENTS>
05300 MK<FSUBR -- TAKES ONLY ONE ARGUMENT,UNBREAKABLE UNLESS 'IN' SOMETHING>
05400 MK<EDITV,GRINPROPS,=EDITV,EDITP,ARGS,EDITFINDP>
05500
05600 ;ATOMS OF GENERATED FUNCTIONS
05700 MK<SUBFUN1ARGPRINT,SUBFUN1BREAKIN0,SUBFUN1EDITCONT,SUBFUN1EDITL1,SUBFUN1EDOR>
05800 MK<SUBFUN1EDVAL,SUBFUN1ERRCOM>
05900 BFWS:
06000 EFWS: 0
06100 RELOC
06200 XLIST
06300 LIT
06400 LIST
06500 BHORG: 0
06600 RELOC
06700 PAGE